Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/PBLIB1/PROGS/SCRNGEN.PAS

Pascal/Delphi Source File | 1994-05-03 | 19KB | 613 lines

Program SCRNGen;

{$M 20000,0,50000}

uses PbMISC, PbDATA, PbOBJS, PbPARMS, PbDDL, PbSCRN;


{
Description:  Starting point for program to generate UNITs

Author      : Howard Richoux
Date        : 2/5/94
Last revised: 1.10  2/8/94  still early development
              1.12  2/18/94 NEW LIBRARIES
Application : IBM PC and compatibles, done in Turbo Pascal 7.0
Status      : Placed in the Public Domain by HNR Software 1/29/94
Published in: none

Intended to be the starting point for future programs like DBPASGEN and BFILEGEN.

This is oriented to producing Units which are essentially OBJECTS with
  the appropriate PASCAL shell around them.

}




var OUTPUTname     : string[40]; { file name for OUTPUT program }
var INPUTname      : string[40]; { file name for SOURCE data }
var INPUText       : string[3];  { default file ext for SOURCE data }
var root           : string[7];  { sort of a central identifier for fields, ... }
var prefix         : string[1];  { like x or z --> "xNAME.pas" }
var AncestorObject : string;     { the object this is derived from }
var CurrentObject  : string;     { THIS OBJECT }
var FieldSpec      : string;     { useful "[fld1(s10,fld2(r10.2)]"  }

var OUTPT          : OUT_object_0; { Lines are output to FILE }
var L              : STRA_object;  { Lines are held here until dumped }



{ MAIN Code }


Procedure LogCRTfile(fn,sect : string);
var i : integer;
     begin
     L.append('{');
     L.append('Screen source file  ['+fn+'] ['+sect+']');
     L.append('');
     L.append('  Screen Dimensions   width: '+integerstr(scrnwidth,2)+
             '   length: '+integerstr(scrnlength,2));
     L.append('  Screen Labels         top:['+scrntoplabl+
             ']   bottom:['+scrnbotlabl+']');
     L.append(' ');
     L.append('  Picture: ');
     for i := 1 to image.count do
          L.append(image.fetchN(i));
     L.append('}');
     end;


Function FieldRootStr(nam : string) : string;
var s : string;
    i : integer;
     begin
     s := nam;
     i := length(s);
     while i > 0 do
          begin
          i := pos('.',s);
          if i > 0 then delete(s,1,i);
          end;
     FieldRootStr := s;
     end;


Function CheckFieldOption(i : integer; option : string) : boolean;
     {[FIELD] Check if "option" is present in opt string }
var s,o,oo : string;
     begin
     CheckFieldOption := false;
     s := flds.ddl[i].options;
     trim(s); UpCaseStr(s);
     oo := option;
     trim(oo); UpCaseStr(oo);
     while length(s) > 0 do
          begin
          o := GetLeftStr(s,',');
          if ( o = oo ) then CheckFieldOption := true;
          end;
     end;



Procedure MakePasFields;
var i,j,len,decp : integer;
    s, nam,typstr  : string;
    typ     : char;
     begin
     for j := 1 to flds.count do
          begin
          nam  := flds.ddl[j].nam;
          typ  := flds.ddl[j].typ;
          len  := flds.ddl[j].len;
          decp := flds.ddl[j].decp;
          typstr := '';
          case typ of
             'C' : begin                    {char array}
                   if len > 1 then
                        typstr := 'array[1..'+integerstr(len,3)+'] of char;'
                   else typstr := 'char;';
                   end;
             'D' : typstr := 'string[8];';  {DBase Date}
             'I' : typstr := 'integer;';    {integer}
             'L' : typstr := 'longint;';    {longint}
             'R' : typstr := 'real;';       {real}
             'S' : begin                  {PASCAL string}
                   if len = 0 then len := 1;
                   if len > 1 then
                        typstr := 'string['+integerstr(len,3)+'];'
                   else typstr := 'char;';
                   end;
              else begin      {unknown}
                   typstr := '{Unknown field type ['+typ+']}';
                   len := 0;
                   end;
              end;
          removeblanks(typstr);
          L.append('          '+leftstr(nam,10)+': '+typstr);
          end;
     end;


Procedure MakeVARData;
var i : integer;
     begin
     L.append(' ');
     if DeclareData then
          begin
          for i := 1 to flds.count do
               L.append('var '+vars.fetchN(i));
          end
     else begin
          L.append('{ Variables declared elsewhere'+ UsesStr+' }');
          end;
     L.append(' ');
     end;


Procedure MakeUnitStart;
var i, width   : integer;
    rtype      : char;
    tmp, tpe   : string[40];
     begin
     L.append('{SECTION ..'+prefix+Root+' }');
     L.append(' ');
     L.append('{ '+pProgID+' - hnr   '+FormatDTime+
              ', Placed in the Public Domain by HNR Software 1/94 }');
     L.append(' ');
     L.append('Unit '+prefix+Root+';');
     L.append(' ');
     L.append('INTERFACE');
     L.append(' ');
     L.append('Uses PbCRT, PbWIND, PbMISC, PbDATA, PbFIELDS '+UsesStr+';');
     L.append(' ');
     MakeVARData;
     L.append(' ');
     L.append(' ');
     LogCRTfile(INPUTname,root);
     L.append(' ');
     end;



Function PbFIELDSectStr( nam : string; typ : char) : string;
var s : string;
     begin
     s := '';
     case typ of
         'D'   : s := 'DBDATE';
         'I'   : s := 'INTEGER';
         'L'   : s := 'LONGINT';
         'R'   : s := 'REAL';
         'S'   : s := 'STRING';
         else    s := 'UNKNOWN';
         end;
     PbFIELDSectStr := leftstr(FieldRootStr(nam)+'_fld',20)+' : '+s+'_FIELD_object;';
     end;


Procedure MakeObjectData;
var i : integer;
     begin
     L.append('         '+'w           : WINDOW_object;');
     L.append('         '+'readonly    : boolean;');
     L.append('         '+'colorscheme : byte;');
     L.append('         '+'exitcmd     : string[24];');
     L.append('         '+'CRTSav      : CRTSaveRec; {Used only by POPUP}');
     L.append(' ');
     for i := 1 to flds.count do
          begin
          if CheckFieldOption(i,'DBDATE') then flds.ddl[i].typ := 'D';
          L.append('         '+PbFIELDSectStr(flds.ddl[i].nam,flds.ddl[i].typ));
          end;
     L.append(' ');
     end;


Procedure ProcessFieldOptions(i : integer);
var s,o : string;
     begin
     s := flds.ddl[i].options;
     trim(s); UpCaseStr(s);
     while length(s) > 0 do
          begin
          o := GetLeftStr(s,',');
          if      o = 'DOLLAR3' then
                       L.append('     '+ FieldRootStr(flds.ddl[i].nam)+'_fld.decp := 3;')
          else if o = 'UPSHIFT' then
                       L.append('     '+ FieldRootStr(flds.ddl[i].nam)+'_fld.SetUpShift;')
          else if o = 'READONLY' then
                       L.append('     '+ FieldRootStr(flds.ddl[i].nam)+'_fld.readonly := true;')
          else if o = 'DBDATE' then begin {handled elsewhere} end
          else begin
               L.append('     { Unknown option ['+ o + '] }');
               end;
          end;
     end;


Procedure GenerateInitLine(i : integer);
     begin
     if flds.ddl[i].typ = 'R' then
          begin
          L.append('     r := ' + integerstr(flds.ddl[i].r,2) + '; '+
                       ' c := ' + integerstr(flds.ddl[i].c,2) + '; '+
                       FieldRootStr(flds.ddl[i].nam)+'_fld.init(r,c,' +
                       integerstr(flds.ddl[i].l,2)+','+
                       integerstr(flds.ddl[i].decp,2)+','+
                       '''' + flds.ddl[i].prompt + '''' + ');' );
          end
     else begin
          L.append('     r := ' + integerstr(flds.ddl[i].r,2) + '; '+
                       ' c := ' + integerstr(flds.ddl[i].c,2) + '; '+
                       FieldRootStr(flds.ddl[i].nam)+'_fld.init(r,c,' +
                       integerstr(flds.ddl[i].l,2)+','+
                       '''' + flds.ddl[i].prompt + '''' + ');' );
          end;
     ProcessFieldOptions(i);
     end;


Procedure MakeObjectInitProc(hdr : boolean);
var i, width   : integer;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  init     ( x,y,color : byte);');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.init( x,y,color : byte );');
          L.append('var r,c : byte;');
          L.append('     begin');
          L.append('     exitcmd := ''?CONTINUE'';');
          L.append('     readonly := false;');
          L.append('     colorscheme := color;');
          L.append('     SetColorScheme(colorscheme);');
          L.append('     w.init(x,y,x+'+integerstr(Scrnwidth,2)+
                                ',y+'+integerstr(scrnlength,2)+',0);');
          L.append('     w.SetLabels(''' +scrntoplabl + '''' + ',' +
                                   + ''''+scrnbotlabl + '''' + ');');
          for i := 1 to flds.count do
               begin
               GenerateInitLine(i);
               end;
          L.append('     end;');
          L.append(' ');
          L.append(' ');
          end;
     end;


Procedure MakeObjectDoneProc(hdr : boolean);
var i, width   : integer;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  done;');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.done;');
          L.append('     begin');
          L.append('     w.done;');
          L.append('     end;');
          L.append(' ');
          L.append(' ');
          end;
     end;



Procedure MakeObjectMethod2(hdr : boolean);
var i, width   : integer;
    s          : string;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  display;');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.display;');
          L.append('     begin');
          L.append('     SetColorScheme(colorscheme);');
          L.append('     w.drawframe;');
          L.append('     w.clrscr;');
          L.append('     PromptColor;');
          for i := 2 to literals.count-1 do
               begin
               s := literals.fetchN(i);
               if s <> '' then
                     begin
                     L.append('     DisplayStr('+ integerstr(i-1,2) + ',1,' +
                               '''' + s + '''' + ');');
                     end;
                end;
          L.append('      DisplayData;');
          L.append('      end;');
          L.append(' ');
          L.append(' ');
          end;
     end;



Procedure MakeObjectMethod1(hdr : boolean);
var i, width   : integer;
    s          : string;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  displaydata;');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.displaydata;');
          L.append('     begin');
          L.append('     SetColorScheme(colorscheme);');
          for i := 1 to flds.count do
               begin
               L.append('     '+ FieldRootStr(flds.ddl[i].nam) + '_fld.display('+
                           flds.ddl[i].nam +');' );
               end;
          L.append('     end;');
          L.append(' ');
          L.append(' ');
          end;
     end;



Procedure MakeObjectMethod3(hdr : boolean);
var i, width   : integer;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  input;');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.input;');
          L.append('var xit  : boolean;');
          L.append('var next : integer;');
          L.append('     begin');
          L.append('     xit := false;');
          L.append('     if readonly then');
          L.append('          begin');
          L.append('          xit := true;');
          L.append('          PbCRT.pause;');
          L.append('          end;');
          L.append('     next := 1;');
          L.append('     while not xit do');
          L.append('          begin');
          L.append('          case next of');
          for i := 1 to flds.count do
               begin
               L.append('               '+ integerstr(i,2)+'   : '+
                                  'if not xit then xit := '+
                                   FieldRootStr(flds.ddl[i].nam) + '_fld.input('+
                                   flds.ddl[i].nam +');' );
               end;
          L.append('               else   next := 0;');
          L.append('               end;');
          L.append('          if HKEY_LastTC = ''H'' then  {UpArrow } ');
          L.append('               begin ');
          L.append('               if next > 1 then dec(next); ');
          L.append('               xit := false; HKEY_LastTC := '' '';');
          L.append('               end');
          L.append('          else if HKEY_LastTC = ''P'' then  {DownArrow } ');
          L.append('               begin ');
          L.append('               inc(next); ');
          L.append('               xit := false; HKEY_LastTC := '' '';');
          L.append('               end');
          L.append('          else inc(next);');
          L.append('          end;');
          L.append('     ExitCmd := FunctionKeyDecode(HKEY_LastTC);');
          L.append('     end;');
          L.append(' ');
          L.append(' ');
          end;
     end;


Procedure MakeObjectMethod4(hdr : boolean);
var i, width   : integer;
    rtype      : char;
    tmp,tmp2,tpe    : string[20];
     begin
     if hdr then
          begin
          L.append('         Procedure  PopUp    ( x,y,color : byte);');
          end
     else begin
          L.append(' ');
          L.append('Procedure  '+CurrentObject+'.PopUp( x,y,color : byte );');
          L.append('var r,c : byte;');
          L.append('     begin');
          L.append('     SaveCRT(CRTSav);');
          L.append('     init(x,y,color);');
          L.append('     display;');
          L.append('     input;');
          L.append('     done;');
          L.append('     RestoreCRT(CRTSav);');
          L.append('     end;');
          L.append(' ');
          L.append(' ');
          end;
     end;



Procedure MakeObjectProcs(hdr : boolean);
     begin
     MakeObjectInitProc(hdr);
     MakeObjectMethod1(hdr);
     MakeObjectMethod2(hdr);
     MakeObjectMethod3(hdr);
     MakeObjectMethod4(hdr);
     MakeObjectDoneProc(hdr);
     end;


Procedure MakeObjectHeader;
var tmp   : string;
     begin
     L.append('{SECTION .'+Root+'_'+AncestorObject+' }');
     L.append(' ');
     tmp := 'OBJECT';
     if AncestorObject <> '' then tmp := 'OBJECT('+AncestorObject+')';
     L.append('type   '+CurrentObject+' = '+tmp);
     MakeObjectData;
     MakeObjectProcs(true);
     L.append('         end;');
     L.append(' ');
     end;


Procedure MakeImplementation;
     begin
     L.append(' ');
     L.append('{SECTION .zImplementation }');
     L.append('IMPLEMENTATION');
     L.append(' ');
     end;


Procedure MakeUnitEnd;
     begin
     L.append(' ');
     L.append('{SECTION zzInitialization }');
     L.append('      begin { initialization }');
     L.append('      end.');
     end;



{ ------------------------------------------------------------------- }

Procedure OUTSTRA(var L : STRA_object);
var i : integer;
    s : string;
     begin
     for i := 1 to L.count do
          begin
          s := L.fetchN(i);
          OUTPT.OUT(s);
          end;
     end;


Procedure GeneratePASCALCode;
var outfname : string[40];
     begin
     L.init(500);
     getdir(0,outfname);
     outfname := addbackslash(outfname) + Prefix + Root;
     forceext(outfname,'pas');
     writeln('Writing to [',outfname,']');
     OUTPT.LISTinit(outfname,OUT_typREWRITE);
     OUTPT.LISTopen;

     MakeUnitStart;
     MakeObjectHeader;
     MakeImplementation;
     MakeObjectProcs(false);
     MakeUnitEnd;

     OUTSTRA(L);
     OUTPT.done;
     end;


Procedure ProcessINPUTfile(fn : string);
     begin
     if fieldSpec <> '' then
          begin
          flds.init;
          FieldSpecToPbDDL(FieldSpec,flds);
          flds.dump;
          end;
     ProcessCRTFile(fn,root,flds);
     {fields.dump;}
     flds.dump;
     end;


Procedure DoSKELGen(OUTPUTname : string);
var fn : string[40];
     begin
     fn := OUTPUTname;
     writeln('fn ',fn);
     writeln('root= ',Root);
     forceext(INPUTname,'crt');
     ProcessINPUTfile( INPUTname );
     GeneratePASCALCode;
     end;


Procedure SKELGenInit;
     begin
     OUTPUTname := 'testunit.pas';   {Unit file to be generated}

     addparm(1,'SOURCE','');
     addparm(1,'SOURCEEXT','txt');
     addparm(1,'FILE','');
     addparm(1,'FIELDS','');
     addparm(1,'ROOT','');
     addparm(1,'PREFIX','z');
     addparm(1,'ANCESTOR','');
     addparm(1,'USES','');

     StandardpVarsInit;

     prefix         := GetParmStr('PREFIX');
     OUTPUTname     := GetParmStr('FILE');
     INPUTname      := GetParmStr('SOURCE');
     INPUText       := GetParmStr('SOURCEEXT');
     UsesStr        := GetParmStr('USES');
     AncestorObject := GetParmStr('ANCESTOR');

     Fieldspec      := GetParmStr('FIELDS');
     Fieldspec      := UpCaseStr(FieldSpec);
     trim(FieldSpec);
     if FieldSpec[1] = '[' then RemoveEnds(FieldSpec);

     if paramcount > 0 then INPUTname := paramstr(1);

     root      := GetParmSTr('ROOT');
     if root = '' then root := FileROOTStr(INPUTName);
     root      := UpCaseStr(root);

     if AncestorObject <> '' then
          CurrentObject := Root + '_' + AncestorObject
     else CurrentObject := Root + '_object';
     end;


     begin
     pProgID := 'SCRNGen 1.09';
     writeln(pProgID, ' - Generate SCREEN Units - HNR 2/94');
     SKELGenInit;
     if INPUTname <> '' then
          begin
          DoSKELGen(INPUTname);
          end
     else writeln('Without specifying a SOURCE= file, there is no point in this exercise');
     writeln('');
     end.